home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / kcl-low.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  14.4 KB  |  416 lines
  1. ;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; The version of low for Kyoto Common Lisp (KCL)
  28. (in-package "SI")
  29. (export '(%structure-name
  30.           %compiled-function-name
  31.           %set-compiled-function-name))
  32. (in-package 'pcl)
  33. (import 'si:structurep)
  34.  
  35. (shadow 'lisp:dotimes)
  36.  
  37. (defmacro dotimes ((var form &optional (val nil)) &rest body &environment env)
  38.   (multiple-value-bind (doc decls bod)
  39.       (extract-declarations body env)
  40.     (declare (ignore doc))
  41.     (let ((limit (gensym))
  42.           (label (gensym)))
  43.       `(let ((,limit ,form)
  44.              (,var 0))
  45.          (declare (fixnum ,limit ,var))
  46.          ,@decls
  47.          (block nil
  48.            (tagbody
  49.             ,label
  50.               (when (>= ,var ,limit) (return-from nil ,val))
  51.               ,@bod
  52.               (setq ,var (the fixnum (1+ ,var)))
  53.               (go ,label)))))))
  54.  
  55. (defun memq (item list) (member item list :test #'eq))
  56. (defun assq (item list) (assoc item list :test #'eq))
  57. (defun posq (item list) (position item list :test #'eq))
  58.  
  59. (si:define-compiler-macro memq (item list) 
  60.   (let ((var (gensym)))
  61.     (once-only (item)
  62.       `(let ((,var ,list))
  63.          (loop (unless ,var (return nil))
  64.                (when (eq ,item (car ,var))
  65.                  (return ,var))
  66.                (setq ,var (cdr ,var)))))))
  67.  
  68. (si:define-compiler-macro assq (item list) 
  69.   (let ((var (gensym)))
  70.     (once-only (item)
  71.       `(dolist (,var ,list nil)
  72.          (when (eq ,item (car ,var))
  73.            (return ,var))))))
  74.  
  75. (si:define-compiler-macro posq (item list) 
  76.   (let ((var (gensym)) (index (gensym)))
  77.     (once-only (item)
  78.       `(let ((,var ,list) (,index 0))
  79.          (declare (fixnum ,index))
  80.          (dolist (,var ,list nil)
  81.            (when (eq ,item ,var)
  82.              (return ,index))
  83.            (incf ,index))))))
  84.  
  85. (defun printing-random-thing-internal (thing stream)
  86.   (format stream "~O" (si:address thing)))
  87.  
  88.  
  89. #+akcl
  90. (eval-when (load compile eval)
  91.  
  92. ;compiler::*compile-ordinaries* is set to t in kcl-patches
  93.  
  94. (if (and (boundp 'si::*akcl-version*)
  95.      (>= si::*akcl-version* 604))
  96.     (progn
  97.       (pushnew :turbo-closure *features*)
  98.       (pushnew :turbo-closure-env-size *features*))
  99.     (when (fboundp 'si::allocate-growth) 
  100.       (pushnew :turbo-closure *features*)))
  101.  
  102. ;; patch around compiler bug.
  103. (when (<= si::*akcl-version* 609)
  104.   (let ((vcs "static int Vcs;
  105. "))
  106.     (unless (search vcs compiler::*cmpinclude-string*)
  107.       (setq compiler::*cmpinclude-string*
  108.         (concatenate 'string vcs compiler::*cmpinclude-string*)))))
  109.  
  110. )
  111.  
  112. (defmacro %svref (vector index)
  113.   `(svref (the simple-vector ,vector) (the fixnum ,index)))
  114.  
  115. (defsetf %svref (vector index) (new-value)
  116.   `(setf (svref (the simple-vector ,vector) (the fixnum ,index))
  117.          ,new-value))
  118.  
  119.  
  120. ;;;
  121. ;;; std-instance-p
  122. ;;;
  123. #-akcl
  124. (si:define-compiler-macro std-instance-p (x)
  125.   (once-only (x)
  126.     `(and (si:structurep ,x)
  127.           (eq (si:%structure-name ,x) 'std-instance))))
  128.  
  129. #+akcl
  130. (progn
  131.  
  132. ;; declare that std-instance-p may be computed simply, and will not change.
  133. (si::freeze-defstruct 'std-instance)
  134.  
  135.  
  136. (defvar *pcl-funcall*  '(lambda (loc)
  137.           (compiler::wt-nl
  138.            "{object _funobj = " loc ";"
  139.            "if(type_of(_funobj)==t_cclosure && (_funobj->cc.cc_turbo))
  140.                    (*(_funobj->cc.cc_self))(_funobj->cc.cc_turbo);
  141.                else if (type_of(_funobj)==t_cfun) (*(_funobj->cc.cc_self))();
  142.                else super_funcall_no_event(_funobj);}")))
  143. (setq compiler::*super-funcall* *pcl-funcall*)
  144.  
  145. )
  146.  
  147. (defun function-ftype-declaimed-p (name)
  148.   "Returns whether the function given by name already has its ftype declaimed."
  149.   (get name 'compiler::proclaimed-function))
  150.  
  151.  
  152. ;;;
  153. ;;; turbo-closure patch.  See the file kcl-mods.text for details.
  154. ;;;
  155. #-turbo-closure-env-size
  156. (clines "
  157. object cclosure_env_nthcdr (n,cc)
  158. int n; object cc;
  159. {  object env;
  160.    if(n<0)return Cnil;
  161.    if(type_of(cc)!=t_cclosure)return Cnil;
  162.    env=cc->cc.cc_env;
  163.    while(n-->0)
  164.      {if(type_of(env)!=t_cons)return Cnil;
  165.       env=env->c.c_cdr;}
  166.    return env;
  167. }")
  168.  
  169. #+turbo-closure-env-size
  170. (clines "
  171. object cclosure_env_nthcdr (n,cc)
  172. int n; object cc;
  173. {  object env,*turbo;
  174.    if(n<0)return Cnil;
  175.    if(type_of(cc)!=t_cclosure)return Cnil;
  176.    if((turbo=cc->cc.cc_turbo)==NULL)
  177.      {env=cc->cc.cc_env;
  178.       while(n-->0)
  179.         {if(type_of(env)!=t_cons)return Cnil;
  180.          env=env->c.c_cdr;}
  181.       return env;}
  182.    else
  183.      {if(n>=fix(*(turbo-1)))return Cnil;
  184.       return turbo[n];}
  185. }")
  186.  
  187. ;; This is the completely safe version.
  188. (defentry cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
  189. ;; This is the unsafe but fast version.
  190. (defentry %cclosure-env-nthcdr (int object) (object cclosure_env_nthcdr))
  191.  
  192. ;;; #+akcl means this is an AKCL newer than 5/11/89 (structures changed)
  193. (eval-when (compile load eval)
  194.  
  195. ;;((name args-type result-type side-effect-p new-object-p c-expression) ...)
  196. (defparameter *kcl-function-inlines*
  197.   '(#-akcl (si:structurep (t) compiler::boolean nil nil "type_of(#0)==t_structure")
  198.     #-akcl (si:%structure-name (t) t nil nil "(#0)->str.str_name")
  199.     #+akcl (si:%structure-name (t) t nil nil "(#0)->str.str_def->str.str_self[0]")
  200.     (si:%compiled-function-name (t) t nil nil "(#0)->cf.cf_name")
  201.     (si:%set-compiled-function-name (t t) t t nil "((#0)->cf.cf_name)=(#1)")
  202.     (cclosurep (t) compiler::boolean nil nil "type_of(#0)==t_cclosure")
  203.     (%cclosure-env (t) t nil nil "(#0)->cc.cc_env")
  204.     (%set-cclosure-env (t t) t t nil "((#0)->cc.cc_env)=(#1)")
  205.     #+turbo-closure
  206.     (%cclosure-env-nthcdr (fixnum t) t nil nil "(#1)->cc.cc_turbo[#0]")
  207.     
  208.     (logxor (fixnum fixnum) fixnum nil nil "((#0) ^ (#1))")))
  209.  
  210. (defun make-function-inline (inline)
  211.   (setf (get (car inline) 'compiler::inline-always)
  212.         (list (if (fboundp 'compiler::flags)
  213.                   (let ((opt (cdr inline)))
  214.                     (list (first opt) (second opt)
  215.                           (logior (if (fourth opt) 1 0) ; allocates-new-storage
  216.                                   (if (third opt) 2 0)  ; side-effect
  217.                                   (if nil 4 0) ; constantp
  218.                                   (if (eq (car inline) 'logxor)
  219.                                       8 0)) ;result type from args
  220.                           (fifth opt)))
  221.                   (cdr inline)))))
  222.  
  223. (defmacro define-inlines ()
  224.   `(progn
  225.     ,@(mapcan #'(lambda (inline)
  226.                   (let ((name (intern (format nil "~S inline" (car inline))))
  227.                         (vars (mapcar #'(lambda (type)
  228.                                           (declare (ignore type))
  229.                                           (gensym))
  230.                                       (cadr inline))))
  231.                     `((make-function-inline ',(cons name (cdr inline)))
  232.                       ,@(when (or (every #'(lambda (type) (eq type 't))
  233.                                          (cadr inline))
  234.                                   (char= #\% (aref (symbol-name (car inline)) 0)))
  235.                           `((defun ,(car inline) ,vars
  236.                               ,@(mapcan #'(lambda (var var-type)
  237.                                             (unless (eq var-type 't)
  238.                                               `((declare (type ,var-type ,var)))))
  239.                                         vars (cadr inline))
  240.                               (,name ,@vars))
  241.                             (make-function-inline ',inline))))))
  242.               *kcl-function-inlines*)))
  243.  
  244. (define-inlines)
  245. )
  246.  
  247. (defsetf si:%compiled-function-name si:%set-compiled-function-name)
  248. (defsetf %cclosure-env %set-cclosure-env)
  249.  
  250. (defun set-function-name-1 (fn new-name ignore)
  251.   (declare (ignore ignore))
  252.   (cond ((compiled-function-p fn)
  253.      (si::turbo-closure fn)
  254.      (when (symbolp new-name) (proclaim-closure new-name))
  255.          (setf (si:%compiled-function-name fn) new-name))
  256.         ((and (listp fn)
  257.               (eq (car fn) 'lambda-block))
  258.          (setf (cadr fn) new-name))
  259.         ((and (listp fn)
  260.               (eq (car fn) 'lambda))
  261.          (setf (car fn) 'lambda-block
  262.                (cdr fn) (cons new-name (cdr fn)))))
  263.   fn)
  264.  
  265.  
  266. (defun proclaim-closure (spec)
  267.   (when (consp spec)
  268.     (setq spec (get-setf-function-name (cadr spec))))
  269.   (unless (function-ftype-declaimed-p spec)
  270.     #+kcl (setf (get spec 'compiler::proclaimed-closure) t)))
  271.  
  272.  
  273. #+akcl (clines "#define AKCL206") 
  274.  
  275. (clines "
  276. #ifdef AKCL206
  277. use_fast_links();
  278. #endif
  279.  
  280. object set_cclosure (result_cc,value_cc,available_size)
  281.   object result_cc,value_cc; int available_size;
  282. {
  283.   object result_env_tail,value_env_tail; int i;
  284. #ifdef AKCL206
  285.   /* If we are currently using fast linking,     */
  286.   /* make sure to remove the link for result_cc. */
  287.   use_fast_links(3,Cnil,result_cc);
  288. #endif
  289.   result_env_tail=result_cc->cc.cc_env;
  290.   value_env_tail=value_cc->cc.cc_env;
  291.   for(i=available_size;
  292.       result_env_tail!=Cnil && i>0;
  293.       result_env_tail=CMPcdr(result_env_tail), value_env_tail=CMPcdr(value_env_tail))
  294.     CMPcar(result_env_tail)=CMPcar(value_env_tail), i--;
  295.   result_cc->cc.cc_self=value_cc->cc.cc_self;
  296.   result_cc->cc.cc_data=value_cc->cc.cc_data;
  297. #ifndef AKCL206
  298.   result_cc->cc.cc_start=value_cc->cc.cc_start;
  299.   result_cc->cc.cc_size=value_cc->cc.cc_size;
  300. #endif
  301.   return result_cc;
  302. }")
  303.  
  304. (defentry %set-cclosure (object object int) (object set_cclosure))
  305.  
  306.  
  307. (pushnew :structure-functions *features*)
  308.  
  309. (defmacro structure-type (x)
  310.   `(si:%structure-name (the structure ,x)))
  311.  
  312. (defun known-structure-type-p (type)
  313.   (or (not (null (gethash type *structure-table*)))
  314.       (let (#+akcl(s-data nil))
  315.         (and (symbolp type)
  316.              #+akcl (setq s-data (get type 'si::s-data))
  317.              #-akcl (get type 'si::is-a-structure)
  318.              (null #+akcl (si::s-data-type s-data)
  319.                    #-akcl (get type 'si::structure-type))))))
  320.  
  321. (defun structure-type-included-type-name (type)
  322.   (or (car (gethash type *structure-table*))
  323.       #+akcl (let ((includes (si::s-data-includes (get type 'si::s-data))))
  324.            (when includes
  325.          (si::s-data-name includes)))
  326.       #-akcl (get type 'si::structure-include)))
  327.  
  328. (defun structure-type-internal-slotds (type)
  329.   #+akcl (si::s-data-slot-descriptions (get type 'si::s-data))
  330.   #-akcl (get type 'si::structure-slot-descriptions))
  331.  
  332. (defun structure-type-slot-description-list (type)
  333.   (or (cdr (gethash type *structure-table*))
  334.       (mapcan #'(lambda (slotd)
  335.                   (when (and slotd (car slotd))
  336.                     (let ((offset (fifth slotd)))
  337.                       (let ((reader #'(lambda (x)
  338.                                         #+akcl (si:structure-ref1 x offset)
  339.                                         #-akcl (si:structure-ref x type offset)))
  340.                             (writer #'(lambda (v x)
  341.                                         (si:structure-set x type offset v))))
  342.                         #+turbo-closure (si:turbo-closure reader)
  343.                         #+turbo-closure (si:turbo-closure writer)
  344.                         (let* ((reader-sym 
  345.                 (let ((*package* *the-pcl-package*))
  346.                   (intern (format nil "~s SLOT~D" type offset))))
  347.                    (writer-sym (get-setf-function-name reader-sym))
  348.                    (slot-name (first slotd))
  349.                    (read-only-p (fourth slotd)))
  350.                           (setf (symbol-function reader-sym) reader)
  351.                           (setf (symbol-function writer-sym) writer)
  352.                           (do-standard-defsetf-1 reader-sym)
  353.                           (list (list slot-name
  354.                                       reader-sym
  355.                       reader
  356.                                       (and (not read-only-p) writer))))))))
  357.               (let ((slotds (structure-type-internal-slotds type))
  358.                     (inc (structure-type-included-type-name type)))
  359.                 (if inc
  360.                     (nthcdr (length (structure-type-internal-slotds inc))
  361.                             slotds)
  362.                     slotds)))))
  363.             
  364.  
  365. (defun structure-slotd-name (slotd)
  366.   (first slotd))
  367.  
  368. (defun structure-slotd-accessor-symbol (slotd)
  369.   (second slotd))
  370.  
  371. (defun structure-slotd-reader-function (slotd)
  372.   (third slotd))
  373.  
  374. (defun structure-slotd-writer-function (slotd)
  375.   (fourth slotd))
  376.  
  377.  
  378.  
  379. ;; Construct files sys-proclaim.lisp and sys-package.lisp
  380. ;; The file sys-package.lisp must be loaded first, since the
  381. ;; package sys-proclaim.lisp will refer to symbols and they must
  382. ;; be in the right packages.   sys-proclaim.lisp contains function
  383. ;; declarations and declarations that certain things are closures.
  384.  
  385. (defun renew-sys-files()
  386.   ;; packages:
  387.   (compiler::get-packages "sys-package.lisp")
  388.   (with-open-file (st "sys-package.lisp"
  389.               :direction :output
  390.               :if-exists :append)
  391.     (format st "(in-package 'SI)
  392. (export '(%structure-name
  393.           %compiled-function-name
  394.           %set-compiled-function-name))
  395. (in-package 'pcl)
  396. "))
  397.  
  398.   ;; proclaims
  399.   (compiler::make-all-proclaims "*.fn")
  400.   (with-open-file (st "sys-proclaim.lisp"
  401.               :direction :output
  402.               :if-exists :append)
  403.     (format st "~%(IN-PACKAGE \"PCL\")~%")
  404.     (print
  405.      `(dolist (v ',
  406.      
  407.            (sloop::sloop for v in-package "PCL"
  408.                  when (get v 'compiler::proclaimed-closure)
  409.                  collect v))
  410.     (setf (get v 'compiler::proclaimed-closure) t))
  411.      st)
  412.     (format st "~%")
  413.     ))
  414.  
  415.  
  416.